home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / tm / tm-def.el.z / tm-def.el
Encoding:
Text File  |  1998-05-21  |  10.6 KB  |  391 lines
  1. ;;; tm-def.el --- definition module for tm
  2.  
  3. ;; Copyright (C) 1995,1996,1997 Free Software Foundation, Inc.
  4.  
  5. ;; Author: MORIOKA Tomohiko <morioka@jaist.ac.jp>
  6. ;; Version: $Id: tm-def.el,v 7.74 1997/04/05 06:42:32 morioka Exp $
  7. ;; Keywords: mail, news, MIME, multimedia, definition
  8.  
  9. ;; This file is part of tm (Tools for MIME).
  10.  
  11. ;; This program is free software; you can redistribute it and/or
  12. ;; modify it under the terms of the GNU General Public License as
  13. ;; published by the Free Software Foundation; either version 2, or (at
  14. ;; your option) any later version.
  15.  
  16. ;; This program is distributed in the hope that it will be useful, but
  17. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  18. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  19. ;; General Public License for more details.
  20.  
  21. ;; You should have received a copy of the GNU General Public License
  22. ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  23. ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  24. ;; Boston, MA 02111-1307, USA.
  25.  
  26. ;;; Code:
  27.  
  28. (require 'emu)
  29.  
  30.  
  31. ;;; @ variables
  32. ;;;
  33.  
  34. (defvar mime/tmp-dir (or (getenv "TM_TMP_DIR") "/tmp/"))
  35.  
  36. (defvar mime/use-multi-frame
  37.   (and (>= emacs-major-version 19) window-system))
  38.  
  39. (defvar mime/find-file-function
  40.   (if mime/use-multi-frame
  41.       (function find-file-other-frame)
  42.     (function find-file)
  43.     ))
  44.  
  45. (defvar mime/output-buffer-window-is-shared-with-bbdb t
  46.   "*If t, mime/output-buffer window is shared with BBDB window.")
  47.  
  48.  
  49. ;;; @ constants
  50. ;;;
  51.  
  52. (defconst mime/output-buffer-name "*MIME-out*")
  53. (defconst mime/temp-buffer-name " *MIME-temp*")
  54.  
  55.  
  56. ;;; @ charset and encoding
  57. ;;;
  58.  
  59. (defvar mime-charset-type-list
  60.   '((us-ascii        7 nil)
  61.     (iso-8859-1        8 "quoted-printable")
  62.     (iso-8859-2        8 "quoted-printable")
  63.     (iso-8859-3        8 "quoted-printable")
  64.     (iso-8859-4        8 "quoted-printable")
  65.     (iso-8859-5        8 "quoted-printable")
  66.     (koi8-r        8 "quoted-printable")
  67.     (iso-8859-7        8 "quoted-printable")
  68.     (iso-8859-8        8 "quoted-printable")
  69.     (iso-8859-9        8 "quoted-printable")
  70.     (iso-2022-jp    7 "base64")
  71.     (iso-2022-kr    7 "base64")
  72.     (euc-kr        8 "base64")
  73.     (gb2312        8 "quoted-printable")
  74.     (big5        8 "base64")
  75.     (iso-2022-jp-2    7 "base64")
  76.     (iso-2022-int-1    7 "base64")
  77.     ))
  78.  
  79. (defun mime/encoding-name (transfer-level &optional not-omit)
  80.   (cond ((> transfer-level 8) "binary")
  81.     ((= transfer-level 8) "8bit")
  82.     (not-omit "7bit")
  83.     ))
  84.  
  85. (defun mime/make-charset-default-encoding-alist (transfer-level)
  86.   (mapcar (function
  87.        (lambda (charset-type)
  88.          (let ((charset  (upcase (symbol-name (car charset-type))))
  89.            (type     (nth 1 charset-type))
  90.            (encoding (nth 2 charset-type))
  91.            )
  92.            (if (<= type transfer-level)
  93.            (cons charset (mime/encoding-name type))
  94.          (cons charset encoding)
  95.          ))))
  96.       mime-charset-type-list))
  97.  
  98.  
  99. ;;; @ button
  100. ;;;
  101.  
  102. (defun tm:set-face-region (b e face)
  103.   (let ((overlay (make-overlay b e)))
  104.     (overlay-put overlay 'face face)
  105.     ))
  106.  
  107. (defvar tm:button-face 'bold
  108.   "Face used for content-button or URL-button of MIME-Preview buffer.
  109. \[tm-def.el]")
  110.  
  111. (defvar tm:mouse-face 'highlight
  112.   "Face used for MIME-preview buffer mouse highlighting. [tm-def.el]")
  113.  
  114. (defvar tm:warning-face nil
  115.   "Face used for invalid encoded-word.")
  116.  
  117. (defun tm:add-button (from to func &optional data)
  118.   "Create a button between FROM and TO with callback FUNC and data DATA."
  119.   (and tm:button-face
  120.        (overlay-put (make-overlay from to) 'face tm:button-face))
  121.   (add-text-properties from to
  122.                (append (and tm:mouse-face
  123.                     (list 'mouse-face tm:mouse-face))
  124.                    (list 'tm-callback func)
  125.                    (and data (list 'tm-data data))
  126.                    ))
  127.   )
  128.  
  129. (defvar tm:mother-button-dispatcher nil)
  130.  
  131. (defun tm:button-dispatcher (event)
  132.   "Select the button under point."
  133.   (interactive "e")
  134.   (let (buf point func data)
  135.     (save-window-excursion
  136.       (mouse-set-point event)
  137.       (setq buf (current-buffer)
  138.         point (point)
  139.         func (get-text-property (point) 'tm-callback)
  140.         data (get-text-property (point) 'tm-data)
  141.         )
  142.       )
  143.     (save-excursion
  144.       (set-buffer buf)
  145.       (goto-char point)
  146.       (if func
  147.       (apply func data)
  148.     (if (fboundp tm:mother-button-dispatcher)
  149.         (funcall tm:mother-button-dispatcher event)
  150.       )
  151.     ))))
  152.  
  153.  
  154. ;;; @ for URL
  155. ;;;
  156.  
  157. (defvar tm:URL-regexp
  158.   "\\(http\\|ftp\\|file\\|gopher\\|news\\|telnet\\|wais\\|mailto\\):\\(//[-a-zA-Z0-9_.]+:[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
  159.  
  160. (defvar browse-url-browser-function nil)
  161.  
  162. (defun tm:browse-url (&optional url)
  163.   (if (fboundp browse-url-browser-function)
  164.       (if url 
  165.         (funcall browse-url-browser-function url)
  166.       (call-interactively browse-url-browser-function))
  167.     (if (fboundp tm:mother-button-dispatcher)
  168.     (call-interactively tm:mother-button-dispatcher)
  169.       )
  170.     ))
  171.  
  172.  
  173. ;;; @ PGP
  174. ;;;
  175.  
  176. (defvar pgp-function-alist
  177.   '(
  178.     ;; for tm-pgp
  179.     (verify        mc-verify            "mc-toplev")
  180.     (decrypt        mc-decrypt            "mc-toplev")
  181.     (fetch-key        mc-pgp-fetch-key        "mc-pgp")
  182.     (snarf-keys        mc-snarf-keys            "mc-toplev")
  183.     ;; for tm-edit
  184.     (mime-sign        tm:mc-pgp-sign-region        "tm-edit-mc")
  185.     (traditional-sign    mc-pgp-sign-region        "mc-pgp")
  186.     (encrypt        tm:mc-pgp-encrypt-region    "tm-edit-mc")
  187.     (insert-key        mc-insert-public-key        "mc-toplev")
  188.     )
  189.   "Alist of service names vs. corresponding functions and its filenames.
  190. Each element looks like (SERVICE FUNCTION FILE).
  191.  
  192. SERVICE is a symbol of PGP processing.  It allows `verify', `decrypt',
  193. `fetch-key', `snarf-keys', `mime-sign', `traditional-sign', `encrypt'
  194. or `insert-key'.
  195.  
  196. Function is a symbol of function to do specified SERVICE.
  197.  
  198. FILE is string of filename which has definition of corresponding
  199. FUNCTION.")
  200.  
  201. (defmacro pgp-function (method)
  202.   "Return function to do service METHOD."
  203.   (` (car (cdr (assq (, method) (symbol-value 'pgp-function-alist)))))
  204.   )
  205.  
  206. (mapcar (function
  207.      (lambda (method)
  208.        (autoload (second method)(third method))
  209.        ))
  210.     pgp-function-alist)
  211.  
  212.  
  213. ;;; @ definitions about MIME
  214. ;;;
  215.  
  216. (defconst mime/tspecials "][\000-\040()<>@,\;:\\\"/?.=")
  217. (defconst mime/token-regexp (concat "[^" mime/tspecials "]+"))
  218. (defconst mime/charset-regexp mime/token-regexp)
  219.  
  220. (defconst mime/content-type-subtype-regexp
  221.   (concat mime/token-regexp "/" mime/token-regexp))
  222.  
  223. (defconst mime/disposition-type-regexp mime/token-regexp)
  224.  
  225.  
  226. ;;; @@ Base64
  227. ;;;
  228.  
  229. (defconst base64-token-regexp "[A-Za-z0-9+/]")
  230. (defconst base64-token-padding-regexp "[A-Za-z0-9+/=]")
  231.  
  232. (defconst mime/B-encoded-text-regexp
  233.   (concat "\\(\\("
  234.       base64-token-regexp
  235.       base64-token-regexp
  236.       base64-token-regexp
  237.       base64-token-regexp
  238.       "\\)*"
  239.       base64-token-regexp
  240.       base64-token-regexp
  241.       base64-token-padding-regexp
  242.       base64-token-padding-regexp
  243.           "\\)"))
  244.  
  245. (defconst mime/B-encoding-and-encoded-text-regexp
  246.   (concat "\\(B\\)\\?" mime/B-encoded-text-regexp))
  247.  
  248.  
  249. ;;; @@ Quoted-Printable
  250. ;;;
  251.  
  252. (defconst quoted-printable-hex-chars "0123456789ABCDEF")
  253. (defconst quoted-printable-octet-regexp
  254.   (concat "=[" quoted-printable-hex-chars
  255.       "][" quoted-printable-hex-chars "]"))
  256.  
  257. (defconst mime/Q-encoded-text-regexp
  258.   (concat "\\([^=?]\\|" quoted-printable-octet-regexp "\\)+"))
  259. (defconst mime/Q-encoding-and-encoded-text-regexp
  260.   (concat "\\(Q\\)\\?" mime/Q-encoded-text-regexp))
  261.  
  262.  
  263. ;;; @ rot13-47
  264. ;;;
  265. ;; caesar-region written by phr@prep.ai.mit.edu  Nov 86
  266. ;; modified by tower@prep Nov 86
  267. ;; gnus-caesar-region
  268. ;; Modified by umerin@flab.flab.Fujitsu.JUNET for ROT47.
  269. (defun tm:caesar-region (&optional n)
  270.   "Caesar rotation of region by N, default 13, for decrypting netnews.
  271. ROT47 will be performed for Japanese text in any case."
  272.   (interactive (if current-prefix-arg    ; Was there a prefix arg?
  273.            (list (prefix-numeric-value current-prefix-arg))
  274.          (list nil)))
  275.   (cond ((not (numberp n)) (setq n 13))
  276.     (t (setq n (mod n 26))))    ;canonicalize N
  277.   (if (not (zerop n))        ; no action needed for a rot of 0
  278.       (progn
  279.     (if (or (not (boundp 'caesar-translate-table))
  280.         (/= (aref caesar-translate-table ?a) (+ ?a n)))
  281.         (let ((i 0) (lower "abcdefghijklmnopqrstuvwxyz") upper)
  282.           (message "Building caesar-translate-table...")
  283.           (setq caesar-translate-table (make-vector 256 0))
  284.           (while (< i 256)
  285.         (aset caesar-translate-table i i)
  286.         (setq i (1+ i)))
  287.           (setq lower (concat lower lower) upper (upcase lower) i 0)
  288.           (while (< i 26)
  289.         (aset caesar-translate-table (+ ?a i) (aref lower (+ i n)))
  290.         (aset caesar-translate-table (+ ?A i) (aref upper (+ i n)))
  291.         (setq i (1+ i)))
  292.           ;; ROT47 for Japanese text.
  293.           ;; Thanks to ichikawa@flab.fujitsu.junet.
  294.           (setq i 161)
  295.           (let ((t1 (logior ?O 128))
  296.             (t2 (logior ?! 128))
  297.             (t3 (logior ?~ 128)))
  298.         (while (< i 256)
  299.           (aset caesar-translate-table i
  300.             (let ((v (aref caesar-translate-table i)))
  301.               (if (<= v t1) (if (< v t2) v (+ v 47))
  302.                 (if (<= v t3) (- v 47) v))))
  303.           (setq i (1+ i))))
  304.           (message "Building caesar-translate-table...done")))
  305.     (let ((from (region-beginning))
  306.           (to (region-end))
  307.           (i 0) str len)
  308.       (setq str (buffer-substring from to))
  309.       (setq len (length str))
  310.       (while (< i len)
  311.         (aset str i (aref caesar-translate-table (aref str i)))
  312.         (setq i (1+ i)))
  313.       (goto-char from)
  314.       (delete-region from to)
  315.       (insert str)))))
  316.  
  317.  
  318. ;;; @ field
  319. ;;;
  320.  
  321. (defun tm:set-fields (sym field-list &optional regexp-sym)
  322.   (or regexp-sym
  323.       (setq regexp-sym
  324.         (let ((name (symbol-name sym)))
  325.           (intern
  326.            (concat (if (string-match "\\(.*\\)-list" name)
  327.                (substring name 0 (match-end 1))
  328.              name)
  329.                "-regexp")
  330.            )))
  331.       )
  332.   (set sym field-list)
  333.   (set regexp-sym
  334.        (concat "^" (apply (function regexp-or) field-list) ":"))
  335.   )
  336.  
  337. (defun tm:add-fields (sym field-list &optional regexp-sym)
  338.   (or regexp-sym
  339.       (setq regexp-sym
  340.         (let ((name (symbol-name sym)))
  341.           (intern
  342.            (concat (if (string-match "\\(.*\\)-list" name)
  343.                (substring name 0 (match-end 1))
  344.              name)
  345.                "-regexp")
  346.            )))
  347.       )
  348.   (let ((fields (eval sym)))
  349.     (mapcar (function
  350.          (lambda (field)
  351.            (or (member field fields)
  352.            (setq fields (cons field fields))
  353.            )
  354.            ))
  355.         (reverse field-list)
  356.         )
  357.     (set regexp-sym
  358.      (concat "^" (apply (function regexp-or) fields) ":"))
  359.     (set sym fields)
  360.     ))
  361.  
  362. (defun tm:delete-fields (sym field-list &optional regexp-sym)
  363.   (or regexp-sym
  364.       (setq regexp-sym
  365.         (let ((name (symbol-name sym)))
  366.           (intern
  367.            (concat (if (string-match "\\(.*\\)-list" name)
  368.                (substring name 0 (match-end 1))
  369.              name)
  370.                "-regexp")
  371.            )))
  372.       )
  373.   (let ((fields (eval sym)))
  374.     (mapcar (function
  375.          (lambda (field)
  376.            (setq fields (delete field fields))
  377.            ))
  378.         field-list)
  379.     (set regexp-sym
  380.      (concat "^" (apply (function regexp-or) fields) ":"))
  381.     (set sym fields)
  382.     ))
  383.  
  384.  
  385. ;;; @ end
  386. ;;;
  387.  
  388. (provide 'tm-def)
  389.  
  390. ;;; tm-def.el ends here
  391.